home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / extras.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  18KB  |  663 lines
  1. ;; Modulised .feelrc
  2.  
  3. ; $Header: /denton_export/denton/You/Modules/RCS/extras.em,v 1.4 1991/01/18 20:09:01 kjp Exp $
  4.  
  5. (defmodule extras 
  6.  
  7.   (ccc 
  8.    lists 
  9.    list-operators 
  10.    others 
  11.    generics 
  12.    classes 
  13.    strings 
  14.    arith 
  15.    errors
  16.    (except (null) class-names)) ()
  17.  
  18.   () ;Poxy, poxy...
  19.  
  20. (defun not (widget) (null widget))
  21.  
  22. (export not)
  23.  
  24. (defun caar (x) (car (car x)))
  25. (defun cadr (x) (car (cdr x)))
  26. (defun cdar (x) (cdr (car x)))
  27. (defun cddr (x) (cdr (cdr x)))
  28.  
  29. (export caar cadr cdar cddr)
  30.  
  31. (defun caaar (x) (car (car (car x))))
  32. (defun caadr (x) (car (car (cdr x))))
  33. (defun cadar (x) (car (cdr (car x))))
  34. (defun caddr (x) (car (cdr (cdr x))))
  35. (defun cdaar (x) (cdr (car (car x))))
  36. (defun cdadr (x) (cdr (car (cdr x))))
  37. (defun cddar (x) (cdr (cdr (car x))))
  38. (defun cdddr (x) (cdr (cdr (cdr x))))
  39.  
  40. (export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
  41.  
  42. (defun caaaar (x) (car (car (car (car x)))) )
  43. (defun caaadr (x) (car (car (car (cdr x)))) )
  44. (defun caadar (x) (car (car (cdr (car x)))) )
  45. (defun caaddr (x) (car (car (cdr (cdr x)))) )
  46. (defun cadaar (x) (car (cdr (car (car x)))) )
  47. (defun cadadr (x) (car (cdr (car (cdr x)))) )
  48. (defun caddar (x) (car (cdr (cdr (car x)))) )
  49. (defun cadddr (x) (car (cdr (cdr (cdr x)))) )
  50. (defun cdaaar (x) (cdr (car (car (car x)))) )
  51. (defun cdaadr (x) (cdr (car (car (cdr x)))) )
  52. (defun cdadar (x) (cdr (car (cdr (car x)))) )
  53. (defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
  54. (defun cddaar (x) (cdr (cdr (car (car x)))) )
  55. (defun cddadr (x) (cdr (cdr (car (cdr x)))) )
  56. (defun cdddar (x) (cdr (cdr (cdr (car x)))) )
  57. (defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
  58.  
  59. (export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
  60.         cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
  61.  
  62. (defun neq (a b) (not (equal a b)))
  63.  
  64. (defun geq (a b) (null (lessp a b)))
  65.  
  66. (defun leq (a b) (null (greaterp a b)))
  67.  
  68. (defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
  69.  
  70. (export neq geq leq eqcar)
  71.  
  72. (defun mkquote (x) (list 'quote x))
  73.  
  74. (export mkquote)
  75.  
  76. (defun assq (a l)
  77.   (cond
  78.    ((null l) nil)
  79.    ((eq a (caar l)) (car l))
  80.    (t (assq a (cdr l)))) )
  81.  
  82. (export assq)
  83.  
  84. (defun list-ref (list n)
  85.   (if (equal n 0) (car list)
  86.     (list-ref (cdr list) (\- n 1))))
  87.  
  88. (defun \@list-ref-update\@ (list n obj)
  89.   (if (equal n 0) ((setter car) list obj)
  90.     (list-ref (cdr list) (\- n 1))))
  91.  
  92. ((setter setter) list-ref \@list-ref-update\@)
  93. (export list-ref)
  94.  
  95. (defun reverse (l)
  96.   (labels ((rev1 (l n)
  97.           (if (null l) n
  98.             (rev1 (cdr l) (cons (car l) n)))))
  99.       (rev1 l nil)))
  100.  
  101. (export reverse)
  102.  
  103. (defun subst (a b c)
  104.    (cond
  105.       ((equal c b) a)
  106.       ((atom c) c)
  107.       (t 
  108.     ((lambda (carc cdrc)
  109.        (cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
  110.               (t (cons carc cdrc))))
  111.      (subst a b (car c))
  112.      (subst a b (cdr c))))))
  113.  
  114. (defun delete (a b comp)
  115.    (cond
  116.       ((null b) nil)
  117.       ((comp a (car b)) (cdr b))
  118.       (t ((lambda (del)
  119.         (cond ((eq del (cdr b)) b)
  120.           (t (cons (car b) del))))
  121.       (delete a (cdr b) comp)))))
  122.  
  123. (defun deleteq (a b)
  124.    (cond
  125.       ((null b) nil)
  126.       ((eq a (car b)) (cdr b))
  127.       (t ((lambda (del)
  128.         (cond ((eq del (cdr b)) b)
  129.           (t (cons (car b) del))))
  130.       (deleteq a (cdr b))))))
  131.  
  132. (export subst delete deleteq)
  133.  
  134. ;; This definition does not allow for arbitary numbers of args
  135. (defun mapcan (*fn* . x)
  136.   (let ((len (list-length x)))
  137.     (cond ((= len 1) (mapcan1 *fn* (car x)))
  138.       ((= len 2) (mapcan2 *fn* (car x) (cadr x)))
  139.       ((= len 3) (mapcan3 *fn* (car x) (cadr x) (caddr x)))
  140.       (t (error 0 "mapcan unfinished")))))
  141.  
  142. (defun mapcan1 (*fn* x)
  143.   (if (null x) nil
  144.      (nconc (*fn* (car x)) (mapcan1 *fn* (cdr x)))))
  145.  
  146. (defun mapcan2 (*fn* x y)
  147.   (if (or (null x) (null y)) nil
  148.      (nconc (*fn* (car x) (car y)) (mapcan2 *fn* (cdr x) (cdr y)))))
  149.  
  150. (defun mapcan3 (*fn* x y z)
  151.   (if (or (null x) (null y) (null z)) nil
  152.      (nconc (*fn* (car x) (car y) (car z))
  153.         (mapcan3 *fn* (cdr x) (cdr y) (cdr z)))))
  154.  
  155.  
  156. ;; This definition does not allow for arbitary numbers of args
  157. (defun mapcon (*fn* . x)
  158.   (let ((len (list-length x)))
  159.     (cond ((= len 1) (mapcon1 *fn* (car x)))
  160.       ((= len 2) (mapcon2 *fn* (car x) (cadr x)))
  161.       ((= len 3) (mapcon3 *fn* (car x) (cadr x) (caddr x)))
  162.       (t (error 0 "mapcon unfinished")))))
  163.  
  164. (defun mapcon1 (*fn* x)
  165.   (if (null x) nil
  166.      (nconc (*fn* x) (mapcon1 *fn* (cdr x)))))
  167.  
  168. (defun mapcon2 (*fn* x y)
  169.   (if (null x) nil
  170.      (nconc (*fn* x y) (mapcon1 *fn* (cdr x) (cdr y)))))
  171.  
  172. (defun mapcon3 (*fn* x y z)
  173.   (if (null x) nil
  174.      (nconc (*fn* x y z) (mapcon3 *fn* (cdr x) (cdr y) (cdr z)))))
  175.  
  176. (export mapcan mapcon)
  177.  
  178. (defun maplist (*fn* l)
  179.    (prog (ans)
  180. top   (cond ((null l) (return (nreverse ans))))
  181.       (setq ans (cons (*fn* l) ans))
  182.       (setq l (cdr l))
  183.       (go top)))
  184.  
  185. (export maplist)
  186.  
  187. ;; Control Extentions - Binding extentions
  188. ;; LET expands to LAMBDA
  189. (defmacro let (bind . body)
  190.   (cons (cons 'lambda (cons (\@letvars bind) body)) (\@letforms bind)))
  191.  
  192. (defun \@letvars (b)
  193.   (if b (cons (car (car b)) (\@letvars (cdr b)))
  194.     nil))
  195.  
  196. (defun \@letforms (b)
  197.   (if b (cons (car (cdr (car b))) (\@letforms (cdr b)))
  198.     nil))
  199.  
  200. ;; LET* expands to LET
  201. (defmacro let* (bind . body)
  202.   (if bind (list 'let (cons (car bind) nil)
  203.          (cons 'let* (cons (cdr bind) body)))
  204.     (cons 'progn body)))
  205.  
  206. ;; LABELS is a complex LET
  207. (defmacro labels (binds . body)
  208.   (cons 'let (cons (\@labelsvar binds) (\@labelsbody binds body))))
  209.  
  210. (defun \@labelsvar (b)
  211.   (if b (cons (list (car (car b)) nil) (\@labelsvar (cdr b)))
  212.     nil))
  213.  
  214. (defun \@labelsbody (b body)
  215.   (if b (cons (list 'setq (car (car b)) (cons 'lambda (cdr (car b))))
  216.           (\@labelsbody (cdr b) body))
  217.     body))
  218.  
  219. (export let let* labels)
  220.  
  221. ;; Control Extentions - Conditional Extentions
  222. (defmacro cond b
  223.   (if b (if (cdr (car b)) (list 'if (car (car b)) (cons 'progn (cdr (car b)))
  224.                 (cons 'cond (cdr b)))
  225.       (list 'or (car (car b)) (cons 'cond (cdr b))))
  226.     nil))
  227.  
  228. (defmacro and b
  229.   (if b (if (cdr b) (list 'if (car b) (cons 'and (cdr b)) nil)
  230.       (car b))
  231.     t))
  232.  
  233. (defmacro or b
  234.   (if b 
  235.       (if (cdr b) (list 'let (list (list '\@ (car b))) 
  236.             (list 'if '\@ '\@ (cons 'or (cdr b))))
  237.     (car b))
  238.     nil))
  239.  
  240. (export cond and or)
  241.   
  242. ;; Control Extentions - Exit Extentions
  243. (defmacro block forms (cons 'let/cc forms))
  244.  
  245. (defmacro return-from (name . forms)
  246.   (list name (cons 'progn forms)))
  247.  
  248. (defmacro catch (tag . body)
  249.   `(let/cc \@
  250.      (dynamic-let ((,tag \@)) ,@body)))
  251.  
  252. (defmacro throw (tag . forms)
  253.   `((dynamic ,tag) (progn ,@forms)))
  254.  
  255. (export block return-from catch throw)
  256.  
  257. ;;(defmacro with-(dummy handler-fn . forms)
  258. ;;  `(let/cc accept
  259. ;;     (let ((decline (current-handler)))
  260. ;;       ((setter current-handler)
  261. ;;         (lambda (condition cont)
  262. ;;           (,handler-fn condition cont)
  263. ;;           ;; Returned => next handler...
  264. ;;           ((setter current-handler) decline)
  265. ;;           (decline condition cont)))
  266. ;;       (unwind-protect
  267. ;;         (progn (unquote-splicing forms))
  268. ;;         ((setter current-handler) decline)))))
  269.  
  270. ;; This is from Christian, and I think that it is not quite right
  271. ;;(defun add-handler (old-handler function)
  272. ;;  (let ((condition) (a) (c))
  273. ;;    (let/cc decline
  274. ;;        (function condition a 
  275. ;;              (lambda () (old-handler condition a decline c))
  276. ;;              c))))
  277.  
  278. ;; (export with-handler add-handler)
  279.  
  280. (defmacro go (a) `(return (,a)))
  281.  
  282. (defmacro return a `(return-from label-block ,@a))
  283.  
  284. ;;(defun \@anylabelsp (forms)
  285. ;;  (if (null forms) nil
  286. ;;    (if (symbolp (car forms)) t
  287. ;;      (\@anylabelsp (cdr forms)))))
  288.  
  289. ;;(defun \@firstlabel (forms)
  290. ;;  (if (null forms) nil
  291. ;;    (if (symbolp (car forms)) (cons (cons (car forms) nil) nil)
  292. ;;      (cons (car forms) (\@firstlabel (cdr forms))))))
  293.  
  294. ;;(defun \@getseqs (forms)
  295. ;;  (if (null forms) nil
  296. ;;    (if (null (symbolp (car forms))) (\@getseqs (cdr forms))
  297. ;;      (cons (cons (cons (car forms)
  298. ;;            (cons nil (\@firstlabel (cdr forms)))) nil)
  299. ;;        (\@getseqs (cdr forms))))))
  300.  
  301. ;;(defmacro tagbody (dummy . forms)
  302. ;;  (if (null (\@anylabelsp forms))
  303. ;;    `(block label-block ,@forms)
  304. ;;    (cons 'block (list 'label-block
  305. ;;             (cons 'labels 
  306. ;;               (append (\@getseqs forms)
  307. ;;                   (\@firstlabel forms)))))))
  308.  
  309. (defun tagbody-til-label (forms)
  310.   (cond ((null forms) nil)
  311.     ((symbolp (car forms)) (tagbody-til-label (cdr forms)))
  312.     (t (cons (car forms) (tagbody-til-label (cdr forms))))))
  313.  
  314. (defun real-tagbody-til-label (forms)
  315.   (cond ((null forms) nil)
  316.     ((symbolp (car forms)) nil)
  317.     (t (cons (car forms) (real-tagbody-til-label (cdr forms))))))
  318.     
  319. (defun tagbody-label-forms (forms)
  320.   (cond ((null forms) nil)
  321.     ((symbolp (car forms))
  322.       (cons
  323.         (cons (car forms) (cons () (tagbody-til-label (cdr forms))))
  324.         (tagbody-label-forms (cdr forms))))
  325.     (t (tagbody-label-forms (cdr forms)))))
  326.  
  327. (defun tagbody-first-label (forms)
  328.   (cond ((null forms) nil)
  329.         ((symbolp (car forms)) (car forms))
  330.     (t (tagbody-first-label (cdr forms)))))
  331.  
  332. (defmacro tagbody forms
  333.   (let ((post (tagbody-label-forms forms))
  334.     (lab1 (tagbody-first-label forms)))
  335.     (if (null post) ;; No labels
  336.       `(block label-block ,@forms)
  337.       `(block label-block
  338.          ,@(real-tagbody-til-label forms) ;; Before any labels
  339.      (labels ,post 
  340.        ,(list lab1)))))) ;; Jump to first label
  341.  
  342. ;; (export go return tagbody)
  343. (export return)
  344.  
  345. (defmacro prog1 forms
  346.   `((lambda (@prog1-handle@)
  347.       ,@(cdr forms)
  348.       @prog1-handle@) ,(car forms)))
  349.  
  350. (export prog1)
  351.  
  352. ;; Quasi-quoting
  353. ;;(defmacro quasiquote (dummy form)
  354. ;;  (labels ((\@unquote-constructor (x)
  355. ;;        (cond ((atom x) 
  356. ;;           (cond ((or (null x) (numberp x) (stringp x) (eq x t)) x)
  357. ;;             (t (mkquote x))))
  358. ;;        
  359. ;;          ((eq (car x) 'unquote) (cadr x))
  360. ;;          ((eq (car x) 'unquote-spicing) 
  361. ;;           (error 0 "Illegal use of ,@ marker"))
  362. ;;          ((eqcar (car x) 'unquote-splicing)
  363. ;;           (list 'append (cadar x) (\@unquote-constructor (cdr x))))
  364. ;; ;;          ((\@contains-no-unquote x) (mkquote x))
  365. ;;          (t (list 'cons 
  366. ;;               (\@unquote-constructor (car x))
  367. ;;               (\@unquote-constructor (cdr x))))))
  368. ;;       (\@contains-no-unquote (x)
  369. ;;        (cond ((atom x) t)
  370. ;;          ((or (eq (car x) 'unquote) (eq (car x) 'unquote-splicing))
  371. ;;           nil)
  372. ;;          (t (and (\@contains-no-unquote (car x))
  373. ;;              (\@contains-no-unquote (cdr x)))))))
  374. ;;      (\@unquote-constructor form)))
  375.  
  376. ;; Having realised the embarrasing overhead of local functions in
  377. ;; the interpretter...
  378.  
  379. ;; Quasi-quoting
  380.  
  381. (defun \@unquote-constructor (x)
  382.   (cond ((atom x) 
  383.      (cond ((or (null x) (numberp x) (stringp x) (eq x t)) x)
  384.            (t (mkquote x))))
  385.     
  386.     ((eq (car x) 'unquote) (cadr x))
  387.     ((eq (car x) 'unquote-spicing) 
  388.      (error 0 "Illegal use of ,@ marker"))
  389.     ((eqcar (car x) 'unquote-splicing)
  390.      (list 'append (cadar x) (\@unquote-constructor (cdr x))))
  391. ;;    ((\@contains-no-unquote x) (mkquote x))
  392.     (t (list 'cons 
  393.          (\@unquote-constructor (car x))
  394.          (\@unquote-constructor (cdr x))))))
  395.  
  396. (defun \@contains-no-unquote (x)
  397.   (cond ((atom x) t)
  398.     ((or (eq (car x) 'unquote) (eq (car x) 'unquote-splicing))
  399.      nil)
  400.     (t (and (\@contains-no-unquote (car x))
  401.         (\@contains-no-unquote (cdr x))))))
  402.  
  403. ;; (defmacro quasiquote (dummy form) (\@unquote-constructor form))
  404.  
  405. (export quasiquote)
  406.  
  407. ;; Multiple-value-bind and multiple-value-setq from Jeff Dalton, but wrong
  408.  
  409. (defmacro multiple-bind (dummy vars multiple-value-form . body)
  410.   `(multiple-value-call (lambda ,vars (unquote-splicing body))
  411.             ,multiple-value-form))
  412.  
  413. (defmacro multiple-setq (dummy vars multiple-value-form)
  414.   ;; get one temp var gensym for each variable
  415.   (let ((temps (mapcar (lambda (v) (gensym))
  416.                        vars)))
  417.     ;; put the multiple values in the temp vars
  418.     `(multiple-value-bind ,temps ,multiple-value-form
  419.              ;; assign the value of each temp var to the corresponding
  420.              ;; variable
  421.              (unquote-splicing (mapcar (lambda (v g) `(setq ,v ,g))
  422.                    vars
  423.                    temps)))))
  424.  
  425.  
  426. ;;;;
  427.  
  428. ;;(deflocal foo1
  429. ;;  (macroexpand
  430. ;;     '(with-handler (lambda (c a d) (print c))
  431. ;;            (signal (make-condition 'bar 123)))))
  432. ;;(deflocal foo2
  433. ;;  (macroexpand
  434. ;;     '(with-handler (lambda (c a d) (print c) (a 456))
  435. ;;            (signal (make-condition 'bar 123)))))
  436. ;;(deflocal foo3
  437. ;;  (macroexpand
  438. ;;     '(with-handler (lambda (c a d) (print c) (d c))
  439. ;;            (signal (make-condition 'bar 123)))))
  440.  
  441.  
  442. ;;;;
  443.  
  444. ;; Noddy evaluator for a file of lisp forms
  445.  
  446. (defun rdf(path)
  447.   (rdf-read-form (open path 'input)))
  448.   
  449. (defun rdf-read-form(instream)
  450.   (let ((form (read instream)))
  451.     (cond ((end-of-stream-p form) (close instream) t)
  452.           (t (eval/cm form) (rdf-read-form instream)))))
  453.  
  454.   (export rdf)
  455.  
  456.   (defmacro prog (vars . body)
  457.     `(block label-block
  458.     ((lambda ,vars (tagbody ,@body)) ,@(mapcar (lambda (a) nil) vars))
  459.         nil))
  460.  
  461.   (export prog)
  462.  
  463. (defmacro when (pred . forms) `(if ,pred (progn ,@forms) nil))
  464. (defmacro unless (pred . forms) `(if ,pred nil (progn ,@forms)))
  465.  
  466. (export when unless)
  467.  
  468. ;; 
  469. ;; Missing bits...
  470. ;;
  471.  
  472. (defgeneric positivep (i))
  473. (export positivep)
  474.  
  475. (defmethod positivep ((i number)) (< i 0))
  476.  
  477. (defgeneric negativep (i))
  478. (export negativep)
  479.  
  480. (defmethod negativep ((i number)) (< i 0))
  481.  
  482. (defgeneric negate (x))
  483. (export negate)
  484.  
  485. (defmethod negate ((x number)) (- x))
  486.  
  487. (defun make-polar (r theta)
  488.   (make-rectangular (* r (cos theta)) (* r (sin theta))))
  489. (export make-polar)
  490.  
  491. (defun argument (x) (atan2 (imaginary-part x) (real-part x)))
  492. (export argument)
  493.  
  494. (defun modulus (x)
  495.   (let ((rr (real-part x))
  496.     (ii (imaginary-part x)))
  497.     (exp (* 0.5 (log (+ (* rr rr) (* ii ii)))))))
  498. (export modulus)
  499.  
  500. (defun list-copy-aux (l new)
  501.   (if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
  502.     new))
  503.  
  504. (defun list-copy (l) (list-copy-aux l nil))
  505.  
  506. (export list-copy)
  507.  
  508. (defun copy-alist (lst)
  509.   (if (null lst) nil
  510.     (cons (cons (caar lst) (cdar lst)) (copy-alist (cdr lst)))))
  511.  
  512. (export copy-alist)
  513.  
  514. (defun list-tail (lst n) (list-tail-aux lst (- (list-length lst) n)))
  515.  
  516. (defun list-tail-aux (lst n)
  517.   (if (> n 0) (list-tail-aux (cdr lst) (- n 1)) lst))
  518.  
  519. (export list-tail)
  520.  
  521. (defun posq (obj lst) (posq-aux obj lst 1))
  522. (defun posq-aux (obj lst n)
  523.   (if (null lst) -1
  524.     (if (eq obj (car lst)) n (posq-aux obj (cdr lst) (+ n 1)))))
  525. (export posq)
  526.  
  527. (defun pos (obj lst) (pos-aux obj lst 1))
  528. (defun pos-aux (obj lst n)
  529.   (if (null lst) -1
  530.     (if (equal obj (car lst)) n (pos-aux obj (cdr lst) (+ n 1)))))
  531. (export pos)
  532.  
  533. (defgeneric binary-max (a b))
  534. (export binary-max)
  535.  
  536. (defmethod binary-max ((a number) (b number)) (max a b))
  537.  
  538. (defgeneric binary-min (a b))
  539. (export binary-min)
  540.  
  541. (defmethod binary-min ((a number) (b number)) (min a b))
  542.  
  543. (defun string-slice (str start end)
  544.   (let ((n (- (+ end 1) start)))
  545.     (string-slice-aux (make-string n) str 0 start end)))
  546. (defun string-slice-aux (new old n start end)
  547.   (if (> start end) new
  548.     (progn ((setter string-ref) new n (string-ref old start))
  549.        (string-slice-aux new old (+ n 1) (+ start 1) end))))
  550. (export string-slice)
  551.  
  552. ; some easy convert methods
  553. (defmethod generic-convert ((x real) (n integer)) (floor x))
  554. (defmethod generic-convert ((n integer) (x real)) (+ n 0.0))
  555.  
  556. ; a simple definition for expt.
  557.  
  558. (defgeneric expt (x n))
  559. (export expt)
  560.  
  561. (defcondition expt-error ())
  562. (defun raise (mess val)
  563.   (signal (make-condition expt-error
  564.                   'message mess
  565.                   'error-value val)
  566.           ()))
  567.  
  568. (defmethod expt ((x object) (n object))
  569.   (signal (raise "not a real in expt" x) ()))
  570.  
  571. (defmethod expt ((x real) (n object))
  572.   (signal (raise "not an integer in expt" n) ()))
  573.  
  574. (defmethod expt ((x object) (n integer))
  575.   (signal (raise "not a real in expt" x) ()))
  576.  
  577. ; probably (expt 2 -1) should be rational 1/2, but we don't have
  578. ; complete support for that at the moment
  579. (defmethod expt ((x integer) (n integer))
  580.   (cond ((= x 0)
  581.          (cond ((< n 0) (raise "inverse of 0 in expt" 0))
  582.            ((= n 0) (raise "0^0 in expt" 0))
  583.            (t 0)))
  584.         ((< n 0)
  585.          (/ 1.0 (expt-real (convert x real) (- n))))
  586.         ((= n 0) 1)
  587.         (t (expt-int x n))))
  588.  
  589. (defmethod expt ((x rational) (n integer))
  590.   (signal (raise "unimplemented rational arithmetic in expt" x) ()))
  591.  
  592. (defmethod expt ((x real) (n integer))
  593.   (cond ((= x 0.0)
  594.          (cond ((< n 0) (raise "inverse of 0.0 in expt" 0))
  595.            ((= n 0) (raise "0.0^0 in expt" 0.0))
  596.            (t 0.0)))
  597.         ((< n 0)
  598.          (/ 1.0 (expt-real x (- n))))
  599.         ((= n 0) 1.0)
  600.         (t (expt-real x n))))
  601.  
  602. ; n a positive integer
  603. ; x a positive integer
  604. (defun expt-int (x n)
  605.   (cond ((zerop n) 1)
  606.         ((= n 1) x)
  607.         (t (let ((xx (expt-int x (/ n 2))))
  608.              (if (evenp n)
  609.              (* xx xx)
  610.              (* xx xx x))))))
  611.  
  612. ; x a non-zero real
  613. (defun expt-real (x n)
  614.   (if (< x 0.0)
  615.       (if (evenp n)
  616.           (expt-pos-real (- x) n)
  617.           (- (expt-pos-real (- x) n)))
  618.       (expt-pos-real x n)))
  619.  
  620. ; x a positive real
  621. (defun expt-pos-real (x n)
  622.   (exp (* n (log x))))
  623.  
  624. (defgeneric generic-open (path . options))
  625. (export generic-open)
  626.  
  627. (defmethod generic-open ((a string) . opt) (apply open a opt))
  628.  
  629. (defgeneric make-io-stream (instream outstream))
  630. (export make-io-stream)
  631.  
  632. (defgeneric generic-read-char (stream))
  633. (export generic-read-char)
  634.  
  635. (defgeneric generic-read-byte (stream))
  636. (export generic-read-byte)
  637.  
  638. (defgeneric generic-peek-char (stream))
  639. (export generic-peek-char)
  640.  
  641. (defgeneric generic-peek-byte (stream))
  642. (export generic-peek-byte)
  643.  
  644. (defgeneric generic-write-char (ch str))
  645. (export generic-write-char)
  646.  
  647. (defgeneric generic-write-byte (n str))
  648. (export generic-write-byte)
  649.  
  650. (defgeneric generic-log (x))
  651. (export generic-log)
  652.  
  653. (defmethod generic-log ((a number)) (log a))
  654. (defmethod generic-log ((a complex))
  655.   (make-rectangular (log (modulus a)) (argument a)))
  656.  
  657. (defun functionp (obj) (subclassp (class-of obj) function))
  658.  
  659. (export functionp)
  660.  
  661. )
  662.  
  663.